home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / SHDK_2 / SHERRMSG.PAS < prev    next >
Pascal/Delphi Source File  |  1992-04-30  |  10KB  |  328 lines
  1. {$I SHDEFINE.INC}
  2.  
  3. {$I SHUNITSW.INC}
  4. {$O-}
  5.  
  6. {$D-,L-}
  7. {$V-}
  8. unit  ShErrMsg;
  9. {
  10.                                 ShErrMsg
  11.  
  12.                          An Exit Procedure Unit
  13.  
  14.                                    by
  15.  
  16.                               Bill Madison
  17.  
  18.                    W. G. Madison and Associates, Ltd.
  19.                           13819 Shavano Downs
  20.                             P.O. Box 780956
  21.                        San Antonio, TX 78278-0956
  22.                              (512)492-2777
  23.                              CIS 73240,342
  24.  
  25.                   Copyright 1991 Madison & Associates
  26.                           All Rights Reserved
  27.  
  28.         This file may  be used and distributed  only in accord-
  29.         ance with the provisions described on the title page of
  30.                   the accompanying documentation file
  31.                               SKYHAWK.DOC
  32. }
  33.  
  34. interface
  35.  
  36. procedure CheckOn;
  37. procedure CheckOff;
  38. {These two procedures turn error checking on and off. If off, control
  39.  is passed directly to the TP exit procedure chain. The default state
  40.  is On.}
  41.  
  42. procedure RunErrorMsg(Code : integer; Msg : string);
  43. {This procedure simulates the effect of a runtime error, but unlike the
  44.  Tp RunError procedure, it uses the entire CODE instead of only the low
  45.  byte. Also unlike Tp RunError and system exit procedures, RunErrorMsg
  46.  reports the error address in normalized form (the offset is always <=
  47.  $F). If, however, a program using ShErrMsg is run from a batch file and
  48.  ErrorLevel is checked, only the low byte will be reported. This is a
  49.  restriction of DOS.}
  50.  
  51. procedure HaltMsg(Code : word; Msg : string); {This procedure simulates
  52.  the effect of the System.Halt procedure, but unlike System.Halt, it uses
  53.  the entire CODE instead of only the low byte. Also unlike Tp Halt and
  54.  system exit procedures, HaltMsg reports the error address in normalized
  55.  form (the offset is always <= $F). If, however, a program using ShErrMsg
  56.  is run from a batch file and ErrorLevel is checked, only the low byte
  57.  will be reported. This is a restriction of DOS.}
  58.  
  59. implementation
  60.  
  61. {The string W and the array of strings M together contain, in coded
  62.  form, all of the built-in runtime error messages. In the array M, an
  63.  "@" is a functional escape character. The byte value of the following
  64.  character is an index into string W. The runtime error message actually
  65.  displayed is constructed by locating the appropriate string in M,
  66.  displaying that string until an "@" is encountered, using the byte
  67.  value of the character following "@" as an index into W, and displaying
  68.  characters from W until a blank is encountered.
  69.  
  70.  While this may seem unnecessarily complex, it provides considerable
  71.  space saving in any programs using ShErrMsg.
  72.  
  73.  It also suggests that W and M be modified only with extreme caution.}
  74.  
  75.  
  76. const
  77.   W : string = 'Cannot '+
  78.                'Device '+
  79.                'Disk '+
  80.                'File '+
  81.                'Floating '+
  82.                'Invalid '+
  83.                'Overlay '+
  84.                'Unknown '+
  85.                'access '+
  86.                'been '+
  87.                'data '+
  88.                'drive '+
  89.                'error '+
  90.                'fault '+
  91.                'file '+
  92.                'files '+
  93.                'for '+
  94.                'format '+
  95.                'found '+
  96.                'has '+
  97.                'input '+
  98.                'memory '+
  99.                'not '+
  100.                'number '+
  101.                'open '+
  102.                'operation '+
  103.                'or '+
  104.                'overflow '+
  105.                'point '+
  106.                'read '+
  107.                'write ';
  108.  
  109. type
  110.   Mstring = string[41];
  111.  
  112. const
  113.   M : array[1..49] of Mstring =
  114.                 ('1 - @" DOS function @Ä',
  115.                  '2 - @ @ @s',
  116.                  '3 - Path @ @s',
  117.                  '4 - Too many @ò @b',
  118.                  '5 - @ @: denied',
  119.                  '6 - @" @] handle - Handle @y @A trashed',
  120.                  '7 - Memory control blocks destroyed',
  121.                  '8 - Insufficient @â',
  122.                  '9 - @" @â block address',
  123.                  '10 - @" environment',
  124.                  '11 - @" @l',
  125.                  '12 - @" @] @: code',
  126.                  '13 - @" @F',
  127.                  '14 - Unused (reserved)',
  128.                  '15 - @" @K @Ä',
  129.                  '16 - @ remove current directory',
  130.                  '17 - @ rename across drives',
  131.                  '18 - No more @b',
  132.                  '100 -  @ @╢ @Q',
  133.                  '101 - @ @╗ @Q - @ probably full',
  134.                  '102 - @ @ assigned',
  135.                  '103 - @ @ @ò',
  136.                  '104 - @ @ @ò @h @}',
  137.                  '105 - @ @ @ò @h output',
  138.                  '106 - @" numeric @l @í @}',
  139.                  '150 - @ @ @╗ protected',
  140.                  '151 - @2 unit',
  141.                  '152 - Drive @ ready',
  142.                  '153 - @2 command',
  143.                  '154 - CRC @Q @ @F',
  144.                  '155 - Bad @K request structure length',
  145.                  '156 - @ seek @Q',
  146.                  '157 - @2 media type',
  147.                  '158 - Sector @ @s',
  148.                  '159 - Printer out of paper',
  149.                  '160 - @ @╗ @W',
  150.                  '161 - @ @╢ @W',
  151.                  '162 - Hardware failure',
  152.                  '200 - Division by zero',
  153.                  '201 - Range check @Q',
  154.                  '202 - Stack @º @Q',
  155.                  '203 - Heap @º @Q',
  156.                  '204 - @" pointer @Ü',
  157.                  '205 - @ @░ @º',
  158.                  '206 - @ @░ underflow',
  159.                  '207 - @" floating @░ @Ü @T 80x87 stack @º',
  160.                  '208 - @* Manager @ installed',
  161.                  '209 - @* @] @╢ @Q',
  162.                  '210 - Object @ initialized');
  163.  
  164. procedure GetNext(var S1, S2  : string);
  165.   var
  166.     T1  : byte;
  167.   begin
  168.     while (S1[1] = ' ') and (Length(S1) > 0) do
  169.       Delete(S1,1,1);
  170.     T1 := Pos(' ',S1);
  171.     if (T1 = 0) then begin
  172.       S2 := S1;
  173.       S1 := '';
  174.       exit;
  175.       end;
  176.     S2 := Copy(S1,1,T1-1);
  177.     Delete(S1,1,T1);
  178.     end;
  179.  
  180. function DisplayMessages(Idx  : word) : string;
  181. {Given an error code "Idx", an error message will be returned. If
  182.  Idx is not recognized, an empty string will be returned.}
  183.   var
  184.     W1  : word;
  185.     IdxS: string[5];
  186.     T1  : byte;
  187.     Msg,
  188.     S1  : string;
  189.     Mx  : Mstring;
  190.   begin
  191.     W1 := 1;
  192.     str(Idx, IdxS);
  193.     IdxS := IdxS + ' ';
  194.     while (Pos(IdxS, M[W1]) <> 1) and (W1 < 49) do begin
  195.       inc(W1);
  196.       end;
  197.     if Pos(IdxS, M[W1]) <> 1 then begin
  198.       DisplayMessages := IdxS + ' Unknown error code';
  199.       exit;
  200.       end;
  201.     Msg := '';
  202.     Mx := M[W1];
  203.     repeat
  204.       GetNext(Mx, S1);
  205.       if S1 <> '' then
  206.         if S1[1] <> '@' then
  207.           Msg := Msg + S1 + ' '
  208.         else begin
  209.           T1 := byte(S1[2]);
  210.           repeat
  211.             Msg := Msg + W[T1];
  212.             inc(T1);
  213.             until W[T1-1] = ' ';
  214.           end;
  215.       until S1 = '';
  216.     DisplayMessages := Msg;
  217.     end; {DisplayMessages}
  218.  
  219. const
  220.   Check4Errors  : boolean = true;
  221.  
  222. procedure CheckOn;
  223.   begin
  224.     Check4Errors := true;
  225.     end;
  226.  
  227. procedure CheckOff;
  228.   begin
  229.     Check4Errors := false;
  230.     end;
  231.  
  232. var
  233.   UsrAddr,
  234.   ExitSave  : pointer;
  235.   UsrCode   : integer;
  236.   UsrMsg    : string[80];
  237.   W1, W2    : word;
  238.  
  239. procedure RunErrorMsg(Code : integer; Msg : string);
  240. {This procedure simulates the effect of a runtime error, but unlike the
  241.  Tp RunError procedure, it uses the entire CODE instead of only the low
  242.  byte.}
  243.   begin
  244.     Inline(
  245.       $36/$8B/$46/$02/       {ss: mov  ax, [bp+2]}
  246.       $A3/>w1/               {    mov  [>w1], ax}
  247.       $36/$8B/$46/$04/       {ss: mov  ax, [bp+4]}
  248.       $A3/>w2);              {    mov  [>w2], ax}
  249.  
  250.     UsrCode := Code;
  251.     UsrMsg  := Msg;
  252.     UsrAddr := ptr(W2, W1);
  253.     System.RunError(Code);
  254.     end;
  255.  
  256. procedure HaltMsg(Code : word; Msg : string);
  257. {This procedure simulates the effect of the System.Halt procedure, but
  258.  unlike System.Halt, it uses the entire CODE instead of only the low
  259.  byte.}
  260.   begin
  261.     UsrCode := Code;
  262.     UsrMsg := Msg;
  263.     System.Halt(Code);
  264.     end;
  265.  
  266. {$F+}
  267. procedure ShErr;
  268.   function HexW(W : Word) : string;
  269.     {-Return hex string for word}
  270.     const
  271.       Digits : array[0..$F] of Char = '0123456789ABCDEF';
  272.     begin
  273.       HexW[0] := #4;
  274.       HexW[1] := Digits[hi(W) shr 4];
  275.       HexW[2] := Digits[hi(W) and $F];
  276.       HexW[3] := Digits[lo(W) shr 4];
  277.       HexW[4] := Digits[lo(W) and $F];
  278.       end;
  279.   function HexPtr(P : Pointer) : string;
  280.     {-Return hex string for pointer}
  281.     var
  282.       LP  : LongInt;
  283.     begin
  284.       LP := (Seg(P^) shl 4) + Ofs(P^);
  285.       HexPtr := HexW(LP shr 4) + ':' + HexW(LP mod $10);
  286.       end;
  287.  
  288.   begin {ShErr}
  289.     ExitProc := ExitSave;
  290.  
  291.     {Process a normal termination, including Halt(0).}
  292.     if (ExitCode = 0) and (ErrorAddr = nil) then exit;
  293.  
  294.     {Process if error messages not desired.}
  295.     if not Check4Errors then exit;
  296.  
  297.     {Process for error messages.}
  298.     if ErrorAddr = nil then begin           {It was a HALT}
  299.       if UsrMsg = '' then    {Display message if there is one}
  300.         exit                 {otherwise, just exit}
  301.       else begin             
  302.         ExitCode := UsrCode;
  303.         WriteLn(^M^J'ErrorLevel ',UsrCode);
  304.         WriteLn('     ',UsrMsg);
  305.         exit;
  306.         end; {else}
  307.       end {if ErrorAddr = nil}
  308.     else if UsrMsg = '' then begin
  309.                                             {Runtime error}
  310.       WriteLn(^M^J^G'Runtime error '+DisplayMessages(ExitCode));
  311.       WriteLn('     Error at '+HexPtr(ErrorAddr));
  312.       end {if HexPtr(ErrorAddr) <> HexPtr(UsrAddr)}
  313.     else begin
  314.       WriteLn(^M^J^G'Runtime error ', UsrCode, ' at ', HexPtr(UsrAddr));
  315.       WriteLn('':5, UsrMsg);
  316.       end;
  317.     ErrorAddr := nil;
  318.     end; {ShErr}
  319. {$F-}
  320.  
  321. begin
  322.   ExitSave := ExitProc;
  323.   ExitProc := @ShErr;
  324.   UsrCode := 0;
  325.   UsrAddr := nil;
  326.   UsrMsg := '';
  327.   end.
  328.